New Star Software Collection/NSS_Collection.iso/3-004 ms visual basic pro 30/4.imz/4.IMA/QUERY.FR_/QUERY.bin

Text File | 1993-04-28 | 18KB | 666 lines

VERSION 2.00
Begin Form fQuery
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Query Builder"
   ClientHeight    =   5130
   ClientLeft      =   1230
   ClientTop       =   1155
   ClientWidth     =   7095
   ControlBox      =   0   'False
   Height          =   5535
   Icon            =   QUERY.FRX:0000
   KeyPreview      =   -1  'True
   Left            =   1170
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   ScaleHeight     =   5112
   ScaleMode       =   0  'User
   ScaleWidth      =   7116
   Top             =   810
   Width           =   7215
   Begin PictureBox ExpressionBox
      BackColor       =   &H00C0C0C0&
      Height          =   1092
      Left            =   120
      ScaleHeight     =   1065
      ScaleWidth      =   6825
      TabIndex        =   17
      Tag             =   "OL"
      Top             =   120
      Width           =   6852
      Begin CommandButton GetValuesButton
         Caption         =   "List Possible &Values"
         Height          =   252
         Left            =   4200
         TabIndex        =   23
         Top             =   720
         Width           =   2292
      End
      Begin ComboBox cValue
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   4080
         Sorted          =   -1  'True
         TabIndex        =   22
         Text            =   "cValue"
         Top             =   360
         Width           =   2652
      End
      Begin ComboBox cOperator
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   2880
         Style           =   2  'Dropdown List
         TabIndex        =   21
         Top             =   360
         Width           =   1092
      End
      Begin ComboBox cField
         BackColor       =   &H00FFFFFF&
         Height          =   288
         Left            =   120
         Style           =   2  'Dropdown List
         TabIndex        =   20
         Top             =   360
         Width           =   2652
      End
      Begin CommandButton ORButton
         Caption         =   "&Or into Criteria"
         Height          =   252
         Left            =   2040
         TabIndex        =   19
         Top             =   720
         Width           =   1812
      End
      Begin CommandButton ANDButton
         Caption         =   "&And into Criteria"
         Height          =   252
         Left            =   120
         TabIndex        =   18
         Top             =   720
         Width           =   1812
      End
      Begin Label OperatorLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Operator:"
         Height          =   192
         Left            =   2880
         TabIndex        =   26
         Top             =   120
         Width           =   972
      End
      Begin Label ValueLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Value:"
         Height          =   192
         Left            =   4080
         TabIndex        =   25
         Top             =   120
         Width           =   1452
      End
      Begin Label FieldNameLabel
         BackColor       =   &H00C0C0C0&
         Caption         =   "Field Name:"
         Height          =   192
         Left            =   120
         TabIndex        =   24
         Top             =   120
         Width           =   1332
      End
   End
   Begin CommandButton JoinButton
      Caption         =   "Set Table &Joins"
      Height          =   255
      Left            =   4440
      TabIndex        =   16
      Top             =   2520
      Width           =   2535
   End
   Begin ListBox cJoinFields
      BackColor       =   &H00FFFFFF&
      Height          =   420
      Left            =   4440
      TabIndex        =   15
      Tag             =   "OL"
      Top             =   2760
      Width           =   2535
   End
   Begin CommandButton CopySQLButton
      Caption         =   "&Copy SQL"
      Height          =   375
      Left            =   3000
      TabIndex        =   14
      Top             =   4680
      Width           =   1095
   End
   Begin ComboBox cOrderByField
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   4440
      Style           =   2  'Dropdown List
      TabIndex        =   12
      Tag             =   "OL"
      Top             =   2160
      Width           =   2535
   End
   Begin ComboBox cGroupByField
      BackColor       =   &H00FFFFFF&
      Height          =   300
      Left            =   4440
      Style           =   2  'Dropdown List
      TabIndex        =   10
      Tag             =   "OL"
      Top             =   1560
      Width           =   2535
   End
   Begin ListBox cTableList
      BackColor       =   &H00FFFFFF&
      Height          =   1590
      Left            =   120
      MultiSelect     =   1  'Simple
      TabIndex        =   9
      Tag             =   "OL"
      Top             =   1560
      Width           =   1575
   End
   Begin CommandButton ShowSQLButton
      Caption         =   "&Show SQL"
      Height          =   375
      Left            =   1680
      TabIndex        =   8
      Top             =   4680
      Width           =   1095
   End
   Begin ListBox cShowFields
      BackColor       =   &H00FFFFFF&
      Height          =   1590
      Left            =   1800
      MultiSelect     =   1  'Simple
      TabIndex        =   5
      Tag             =   "OL"
      Top             =   1560
      Width           =   2535
   End
   Begin CommandButton CloseButton
      Cancel          =   -1  'True
      Caption         =   "Close"
      Height          =   375
      Left            =   5640
      TabIndex        =   2
      Top             =   4680
      Width           =   1095
   End
   Begin CommandButton RunQueryButton
      Caption         =   "&Run Query"
      Height          =   375
      Left            =   360
      TabIndex        =   1
      Top             =   4680
      Width           =   1095
   End
   Begin CommandButton ClearButton
      Caption         =   "C&lear All"
      Height          =   375
      Left            =   4320
      TabIndex        =   0
      Top             =   4680
      Width           =   1095
   End
   Begin TextBox cCriteria
      BackColor       =   &H00FFFFFF&
      Height          =   1215
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   3
      Tag             =   "OL"
      Top             =   3360
      Width           =   6855
   End
   Begin Label OrberByFieldLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Order By Field:"
      Height          =   192
      Left            =   4440
      TabIndex        =   13
      Top             =   1920
      Width           =   2055
   End
   Begin Label GroupByFieldLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Group By Field:"
      Height          =   192
      Left            =   4440
      TabIndex        =   11
      Top             =   1320
      Width           =   2055
   End
   Begin Label TableListLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Select Tables:"
      Height          =   192
      Left            =   120
      TabIndex        =   7
      Top             =   1320
      Width           =   1455
   End
   Begin Label ShowFieldsLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Select Fields to Show:"
      Height          =   192
      Left            =   1800
      TabIndex        =   6
      Top             =   1320
      Width           =   2055
   End
   Begin Label CriteriaLabel
      BackColor       =   &H00C0C0C0&
      Caption         =   "Criteria:"
      Height          =   180
      Left            =   120
      TabIndex        =   4
      Top             =   3150
      Width           =   1335
   End
End

Dim FShowSQL As Integer
Dim FCopySQL As Integer

Sub ANDButton_Click ()
  Dim f As Field

  If cField = "" Then Exit Sub

  Set f = gCurrentDB.TableDefs(stSTF((cField), 0)).Fields(stSTF((cField), 1))

  If cCriteria <> "" Then
    cCriteria = cCriteria + Chr(13) + Chr(10) + "And "
  End If
  If f.Type = FT_STRING Or f.Type = FT_MEMO Or f.Type = FT_DATETIME Then
    cCriteria = cCriteria + cField + " " + cOperator + " '" + cValue + "'"
  Else
    cCriteria = cCriteria + cField + " " + cOperator + " " + cValue
  End If
  cField.SetFocus
End Sub

Sub cField_Click ()
  cValue.Clear
End Sub

Sub ClearButton_Click ()
  cCriteria = ""
End Sub

Sub CloseButton_Click ()
  Unload Me
End Sub

Sub CopySQLButton_Click ()
  FCopySQL = True
  Call RunQueryButton_Click
  FCopySQL = False
End Sub

Sub cTableList_Click ()
  Dim i As Integer, ii As Integer
  Dim t As TableDef
  Dim st As String

  MsgBar "Updating Form Fields", True
  cField.Clear
  cShowFields.Clear
  cGroupByField.Clear
  cOrderByField.Clear
  cValue.Clear

  cGroupByField.AddItem "(none)"
  cOrderByField.AddItem "(none)"

  For ii = 0 To cTableList.ListCount - 1
    If cTableList.Selected(ii) Then
      Set t = gCurrentDB.TableDefs(cTableList.List(ii))
      For i = 0 To t.Fields.Count - 1
        st = cTableList.List(ii) + "." + t.Fields(i).Name
        cField.AddItem st
        cShowFields.AddItem st
        cGroupByField.AddItem st
        cOrderByField.AddItem st
      Next
    End If
  Next
  If cField.List(0) <> "" Then
    cField.ListIndex = 0
    cGroupByField.ListIndex = 0
    cOrderByField.ListIndex = 0
  End If
  MsgBar "", False

End Sub

Sub Form_Load ()
   On Local Error GoTo FLErr

   Dim ds As DynaSet
   Dim i As Integer
   Dim t As TableDef

   'Clear listbox
   cCriteria = ""

   'Fill the Operator combo
   cOperator.AddItem "="
   cOperator.AddItem "<>"
   cOperator.AddItem ">"
   cOperator.AddItem ">="
   cOperator.AddItem "<"
   cOperator.AddItem "<="
   cOperator.AddItem "Like"
   cOperator.ListIndex = 0

   'fill the table list
   For i = 0 To fTables.cTableList.ListCount - 1
     cTableList.AddItem fTables.cTableList.List(i)
   Next
   cTableList.ListIndex = 0

   cValue = ""

  GoTo FLEnd

FLErr:
  ShowError
  Resume FLEnd

FLEnd:
  Height = 5520
  Width = 7224
  Left = (VDMDI.Width - Width) / 2
  Top = 0

End Sub

Sub Form_Paint ()
  Outlines Me
  PicOutlines ExpressionBox, cField
  PicOutlines ExpressionBox, cOperator
  PicOutlines ExpressionBox, cValue
End Sub

Sub Form_Resize ()
  On Error Resume Next

  If WindowState <> 1 Then
    Height = 5520
    Width = 7224
  End If
End Sub

Sub GetValuesButton_Click ()
  Dim ds As DynaSet

  On Error GoTo GVErr

  MsgBar "Getting Possible Values", True
  SetHourglass Me
  Set ds = gCurrentDB.CreateDynaset("select Distinct " + (cField) + " from " + stSTF((cField), 0))
  Do While ds.EOF = False
    If Trim(ds(0)) <> "" Then
      cValue.AddItem ds(0).Value
    End If
    ds.MoveNext
  Loop
  ds.Close
  cValue = cValue.List(0)
  cValue.SetFocus

  GoTo GVEnd

GVErr:
  cValue = ""
  Resume GVEnd

GVEnd:
  ResetMouse Me
  MsgBar "", False

End Sub

Sub JoinButton_Click ()
  Dim i As Integer
  Dim c As Integer

  For i = 0 To cTableList.ListCount - 1
    If cTableList.Selected(i) = True Then
      c = c + 1
    End If
  Next
  If c < 2 Then
    Beep
    MsgBox "You Must Have at Least 2 Tables Selected!", 48
  Else
    MsgBar "Choose Joins", False
    fJoin.Show MODAL
    MsgBar "", False
  End If
End Sub

Sub ORButton_Click ()
  Dim f As Field

  If cField = "" Then Exit Sub

  Set f = gCurrentDB.TableDefs(stSTF((cField), 0)).Fields(stSTF((cField), 1))

  If cCriteria <> "" Then
    cCriteria = cCriteria + Chr(13) + Chr(10) + " Or "
  End If
  If f.Type = FT_STRING Or f.Type = FT_MEMO Or f.Type = FT_DATETIME Then
    cCriteria = cCriteria + cField + " " + cOperator + " '" + cValue + "'"
  Else
    cCriteria = cCriteria + cField + " " + cOperator + " " + cValue
  End If
  cField.SetFocus

End Sub

Sub RunQueryButton_Click ()

  On Error GoTo OKErr

     Dim ds As DynaSet
     Dim fs As String
     Dim ts As String
     Dim i As Integer

    MsgBar "Building Query", True
     If cCriteria <> "" Then
       stWhere$ = "AND " + LTrim(cCriteria)
       'strip CRLFs
       For i = 1 To Len(stWhere$)
         If Mid(stWhere$, i, 1) = Chr$(13) Then
           stTmp$ = stTmp$ + " "
         ElseIf Mid(stWhere$, i, 1) = Chr$(10) Then
           'do nothing
         Else
           stTmp$ = stTmp$ + Mid(stWhere$, i, 1)
         End If
       Next
       stWhere$ = stTmp$

       stWhere$ = RTrim(stWhere$)

       'Add parens to stWhere$
        stTmpWhere$ = stWhere$
        Do
          stTmp$ = stGetToken(stTmpWhere$, " ")
          If fMatchParen% = False And UCase(stTmp$) = "AND" Then
            stNewWhere$ = stNewWhere$ + stTmp$ + " ("
            fMatchParen% = True
          ElseIf fMatchParen% = True And UCase(stTmp$) = "AND" Then
            stNewWhere$ = stNewWhere$ + ") " + stTmp$ + " ("
            'fMatchParen% = False
          Else
            If UCase(stTmp$) = "OR" Or UCase(stTmp$) = "IN" Or UCase(stTmp$) = "LIKE" Then
              stNewWhere$ = stNewWhere$ + " " + stTmp$ + " "
            Else
              stNewWhere$ = stNewWhere$ + stTmp$
            End If
          End If

        Loop Until stTmpWhere$ = ""
        stWhere$ = stNewWhere$ + ")"

       'Build DynaSet string:
       'Peel off leading AND/OR
       If Mid(stWhere$, 2, 2) = "OR" Then
         stWhere$ = Mid(stWhere$, 5, Len(stWhere$) - 5)
       Else
         stTmp$ = stGetToken(stWhere$, " ")
       End If

       If stWhere$ <> "" Then
         stWhere$ = " Where " + stWhere$
       End If

     End If

     'check for join condition
     If cJoinFields.ListCount > 0 Then
       If stWhere$ = "" Then
         stWhere$ = stWhere$ + " Where "
       Else
         stWhere$ = stWhere$ + " And "
       End If
       For i = 0 To cJoinFields.ListCount - 1
         stWhere$ = stWhere$ + cJoinFields.List(i) + " And "
       Next
       stWhere$ = Mid(stWhere$, 1, Len(stWhere$) - 5)
     End If

     'check for group by field
     If cGroupByField <> "(none)" Then
       stWhere$ = stWhere$ + " Group By " + cGroupByField
     End If

     'check for order by field
     If cOrderByField <> "(none)" Then
       stWhere$ = stWhere$ + " Order By " + cOrderByField
     End If

     'get show field names
     For i% = 0 To cShowFields.ListCount - 1
       If cShowFields.Selected(i%) Then
         fs = fs + cShowFields.List(i%) + ","
       End If
     Next
     If fs = "" Then
       For i% = 0 To cTableList.ListCount - 1
         If cTableList.Selected(i%) Then
           fs = fs + cTableList.List(i%) + ".*,"
         End If
       Next
       If fs = "" Then
         fs = "*"
       Else
         fs = Mid(fs, 1, Len(fs) - 1)     'take off the last ","
       End If
     Else
       fs = Mid(fs, 1, Len(fs) - 1)
     End If

     'get table names
     For i% = 0 To cTableList.ListCount - 1
       If cTableList.Selected(i%) Then
         ts = ts + cTableList.List(i%) + ","
       End If
     Next
     ts = Mid(ts, 1, Len(ts) - 1)

     gstDynaString = "Select " + fs + " From " + ts + stWhere$

     If FShowSQL = False And FCopySQL = False Then
       MsgBar "Running Query", True
       gfFromSQL = True
       'create a new dynaset form
       If VDMDI.cSingleRecord = True Then
         Dim dsform1 As New fDynaset
         dsform1.Show
       Else
         Dim dsform2 As New fGridFrm
         dsform2.Show
       End If
     ElseIf FShowSQL = True Then
       MsgBar "", False
       MsgBox gstDynaString, 0, "SQL Query"
     ElseIf FCopySQL = True Then
       fSQL.cSQLStatement = gstDynaString
     End If

  GoTo OKEnd

OKErr:
  If Err = 364 Then Resume OKEnd   'catch unloaded form
  ShowError
  Resume OKEnd

OKEnd:
  MsgBar "", False

End Sub

Sub ShowSQLButton_Click ()
  FShowSQL = True
  Call RunQueryButton_Click
  FShowSQL = False
End Sub

Function stGetToken (stLn$, stDelim$) As String
    On Error GoTo GetTokenError

    iOpenQuote% = InStr(1, stLn$, """")
    iDelim% = InStr(1, stLn$, stDelim$)

    If (iOpenQuote% > 0) And (iOpenQuote% < iDelim%) Then
         iCloseQuote% = InStr(iOpenQuote% + 1, stLn$, """")
         iDelim% = InStr(iCloseQuote% + 1, stLn$, stDelim$)
    End If

    If (iDelim% <> 0) Then
         stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1, iDelim% - 1)))
         stLn$ = Mid$(stLn$, iDelim% + 1)
    Else
         stToken$ = LTrim$(RTrim$(Mid$(stLn$, 1)))
         stLn$ = ""
    End If

    If (Len(stToken$) > 0) Then
         If (Mid$(stToken$, 1, 1) = """") Then
              stToken$ = Mid$(stToken$, 2)
         End If
         If (Mid$(stToken$, Len(stToken$), 1) = """") Then
              stToken$ = Mid$(stToken$, 1, Len(stToken$) - 1)
         End If
    End If
    stGetToken = stToken$

GetTokenExit:
    Exit Function

GetTokenError:
    Resume GetTokenExit
End Function

'function to split the table and the field from a tbl.fld pair
Function stSTF (tf As String, part As Integer) As String
  If part = 0 Then
    stSTF = Mid(tf, 1, InStr(1, tf, ".") - 1)
  Else
    stSTF = Mid(tf, InStr(1, tf, ".") + 1, Len(tf))
  End If
End Function